Postwork_R

Equipo 10

15/7/2021

🏅 EQUIPO 10

BEDU SANTANDER UNIVERSIDADES

👩🏻🧑🏽 Integrantes

  • María Magdalena Castro Sam

  • Sergio Napoleón Leal

  • Jesús Omar Magaña Medina

  • Fernando Itzama Novales Campos

  • Adrián Ramírez Cortés

  • Efraín Soto Olmos

Descripción

Éste código analiza algunos datos de la primera división de la liga española, obtenidos de https://www.football-data.co.uk/spainm.php. Más notas sobre los datos pueden encontrarse en https://www.football-data.co.uk/notes.txt.

📌 Índice

  • 📂 POSTWORK 1

    • 🔢 get.freq()
    • 📋 Tablas de Frecuencias
    • 🔢 get.prob.m.tbl()
    • 📋 Probabilidad Marginal
    • 🔢 get.prob.df() y get.round()
    • 📋 Frecuencias y Probabilidad Marginal
    • 🔢 get.prob.joint.tbl() y get.prob.joint.df
    • 📋 Probabilidad Conjunta

  • 📂 POSTWORK 2

    • 📋 Importar datos
    • 📋 Revisión de estructura de los Datos
    • 📋 Selección de columnas
    • 📋 Corrección y Unión de Datos
    • 📋 Escritura de Archivo

  • 📂 POSTWORK 3

    • 📋 Local: Probabilidad Marginal
    • 🔢 plot.bar()
    • 📊 Local: P(x) Marginal
    • 📋 Visitante: Probabilidad Marginal
    • 📊 Visitante: P(y) Marginal
    • 📋 Probabilidad Conjunta P(x∩y)
    • 🔢 plot.heatmap()
    • 📊 Heat Map P(x∩y) Conjunta

  • 📂 POSTWORK 4

    • 📋 Probabilidad Marginal
    • 📋 Producto de Probabilidades Marginales
    • 📋 Probabilidad Conjunta P(x∩y)
    • 📋 Cociente de Probabilidades
    • 📋 Bootstrap
    • 🔢 bootstraps() rsample
    • 📋 Medias Muestrales
    • 📋 Intervalos de confianza
    • 🔢 plot.histogram()
    • 📊 Histograma medias bootstrap
    • 📊 Histograma original
    • 📋 Pruebas t
    • 🏁 Conclusiones

  • 📂 Postwork 5

    • 📋 Escribir soccer.csv
    • 📋 fbRanks: anotaciones y equipos
    • 📋 Ranking de Equipos
    • 📋 Predicción Última Fecha
    • 📋 Matriz de Confusión
    • 🏁 Conclusiones

  • 📂 Postwork 6

  • 📂 Postwork 7

    • 📋 Alojar match.data.csv a match_games
    • 📋 Número de Registros
    • 📋 Consulta Sintaxis Mongodb
    • 📋 Cerrar Conexión

  • 📂 Postwork 8

    • 📋 Creamos el logo para la aplicación Shiny
    • 📋 Definimos la UI para la aplicacion
    • 📋 Definimos las funciones del servidor

📂 POSTWORK 1

Importamos las bibliotecas con las que trabajaremos:

library(dplyr)

Importamos datos de la primera división 2019-2020:

data <- read.csv("https://www.football-data.co.uk/mmz4281/1920/SP1.csv")

Vemos la ayuda del comando table:

?table

🔢 get.freq()

get.freq <- function(data, team, name.freq){
  team <- enquo(team)
  data %>%
    pull(!!team) %>%
    table(., dnn = name.freq) 
}

📋 Tablas de Frecuencias

Extraemos las columnas, obtenemos la frecuencia marginal para el equipo de casa y visitante en una función. con table generamos una tabla que nos indica la frecuencia de los goles:

Equipo Local

freq.m.local <- 
  get.freq(data, FTHG, "Freq.Home")

(freq.m.local)
## Freq.Home
##   0   1   2   3   4   5   6 
##  88 132  99  38  14   8   1

Equipo Visitante

freq.m.visit <- 
  get.freq(data, FTAG, "Freq.Away")

(freq.m.visit)
## Freq.Away
##   0   1   2   3   4   5 
## 136 134  81  18   9   2

🔢 get.prob.m.tbl()

get.prob.m.tbl <- function(data, team, name.prob){
  team <- enquo(team)
  data %>%
    pull(!!team) %>%
    table %>%
    prop.table -> prob.tbl
  
  names(attributes(prob.tbl)$dimnames) <- name.prob
  return(prob.tbl)
}

📋 Probabilidad Marginal

La probabilidad marginal es la probabilidad de que ocurra un evento simple, por lo tanto estará dada por el número de goles sobre el total de los partidos.

Calcularemos la probabilidad de que el equipo que juegue en casa anote ’x’ goles en una función:

Equipo Local

La probabilidad marginal de que el equipo que juega local anote x goles (x = 0, 1, 2, …)

prob.m.local <- 
  get.prob.m.tbl(data, FTHG, "Prob.Home")

(prob.m.local %>% round(3))
## Prob.Home
##     0     1     2     3     4     5     6 
## 0.232 0.347 0.261 0.100 0.037 0.021 0.003

Equipo Visitante

La probabilidad marginal de que el equipo que juega como visitante anote y goles (y = 0, 1, 2, …)

En el caso del equipo vistante el procedimiento es análogo.

prob.m.visit <- 
  get.prob.m.tbl(data, FTAG, "Prob.Away")

(prob.m.visit %>% round(3))
## Prob.Away
##     0     1     2     3     4     5 
## 0.358 0.353 0.213 0.047 0.024 0.005

🔢 get.prob.df() y get.round()

get.prob.df<- function(data, team, name.gol, name.prob){ 
  team      <- enquo(team)
  data %>% 
    pull(!!team) %>% 
    table(., dnn = (name.gol)) %>% 
    as.data.frame %>% 
    mutate(!!name.prob := Freq/sum(Freq)) 
}
get.round <- function(data, digits){
  data %>% mutate_if(is.numeric, round, digits=digits)
}

📋 Frecuencias y Probabilidad Marginal

Obtenemos un dataframe con las frecuencias y probabilidades con una función y redondeamos:

Equipo Local

data.local <- get.prob.df(data, FTHG, "Gol.Home", "Prob.Marginal")

(data.local %>% get.round(3))
##   Gol.Home Freq Prob.Marginal
## 1        0   88         0.232
## 2        1  132         0.347
## 3        2   99         0.261
## 4        3   38         0.100
## 5        4   14         0.037
## 6        5    8         0.021
## 7        6    1         0.003

Equipo Visitante

data.visit <- get.prob.df(data, FTAG, "Gol.Away", "Prob.Marginal" )

(data.visit %>% get.round(3))
##   Gol.Away Freq Prob.Marginal
## 1        0  136         0.358
## 2        1  134         0.353
## 3        2   81         0.213
## 4        3   18         0.047
## 5        4    9         0.024
## 6        5    2         0.005

🔢 get.prob.joint.tbl() y get.prob.joint.df

get.prob.joint.tbl <- function(data, team.h, team.a, name.h, name.a){
  data %>%
  {table( team.h,  team.a, dnn = c(name.h, name.a)) } %>% 
  prop.table
}
 
get.prob.joint.df <- function(data, team.h, team.a, name.h, name.a){
  data %>%
  {table( team.h,  team.a, dnn = c(name.h, name.a)) } %>% 
  prop.table %>% 
  unclass %>% 
  as.data.frame
}

📋 Probabilidad Conjunta P(x∩y)

La probabilidad conjunta toma en cuenta la probabilidad de dos eventos sobre el total de resultados posibles.

Calcularemos la probabilidad conjunta de que el equipo local anote ‘x’ goles y el visitante’y’ goles (x = 0, 1, 2, …, y = 0, 1, 2, …) con una función:

table.prob.joint <-
  get.prob.joint.tbl(data, data$FTHG, data$FTAG, "x (Home)", "y (Away)")

(table.prob.joint %>% round(3))
##         y (Away)
## x (Home)     0     1     2     3     4     5
##        0 0.087 0.074 0.039 0.021 0.005 0.005
##        1 0.113 0.129 0.084 0.013 0.008 0.000
##        2 0.103 0.092 0.053 0.008 0.005 0.000
##        3 0.037 0.037 0.018 0.005 0.003 0.000
##        4 0.011 0.013 0.011 0.000 0.003 0.000
##        5 0.005 0.008 0.008 0.000 0.000 0.000
##        6 0.003 0.000 0.000 0.000 0.000 0.000

📂 POSTWORK 2

Importamos bibliotecas:

library(dplyr)
library(magrittr)

Ahora agregamos aún más datos. Utilizaremos los datos de las temporadas 2017/2018, 2018/2019 y 2019/2020.

📋 Importar datos

Importamos los datos a una lista:

temporadas <- c( SP1.1718 = "https://www.football-data.co.uk/mmz4281/1718/SP1.csv"
               , SP1.1819 = "https://www.football-data.co.uk/mmz4281/1819/SP1.csv"
               , SP1.1920 = "https://www.football-data.co.uk/mmz4281/1920/SP1.csv"
               ) %>% lapply(read.csv)

📋 Revisión de estructura de los datos

Revisamos su estructura:

Solo se muestran las primeras 6 líneas de la consola

get.info <- function(data){
  data %>% str
  data %>% head
  data %>% summary
  data %>% View
}
temporadas["SP1.1718"] %>% get.info
## List of 1
##  $ SP1.1718:'data.frame':    380 obs. of  64 variables:
##   ..$ Div       : chr [1:380] "SP1" "SP1" "SP1" "SP1" ...
##   ..$ Date      : chr [1:380] "18/08/17" "18/08/17" "19/08/17" "19/08/17" ...
##   ..$ HomeTeam  : chr [1:380] "Leganes" "Valencia" "Celta" "Girona" ...
##   ..$ AwayTeam  : chr [1:380] "Alaves" "Las Palmas" "Sociedad" "Ath Madrid" ...
...
temporadas["SP1.1819"] %>% get.info
## List of 1
##  $ SP1.1819:'data.frame':    380 obs. of  61 variables:
##   ..$ Div       : chr [1:380] "SP1" "SP1" "SP1" "SP1" ...
##   ..$ Date      : chr [1:380] "17/08/2018" "17/08/2018" "18/08/2018" "18/08/2018" ...
##   ..$ HomeTeam  : chr [1:380] "Betis" "Girona" "Barcelona" "Celta" ...
##   ..$ AwayTeam  : chr [1:380] "Levante" "Valladolid" "Alaves" "Espanol" ...
...
temporadas["SP1.1920"] %>% get.info
## List of 1
##  $ SP1.1920:'data.frame':    380 obs. of  105 variables:
##   ..$ Div        : chr [1:380] "SP1" "SP1" "SP1" "SP1" ...
##   ..$ Date       : chr [1:380] "16/08/2019" "17/08/2019" "17/08/2019" "17/08/2019" ...
##   ..$ Time       : chr [1:380] "20:00" "16:00" "18:00" "19:00" ...
##   ..$ HomeTeam   : chr [1:380] "Ath Bilbao" "Celta" "Valencia" "Mallorca" ...
...

Vemos que hay un diferente formato de fechas en la temporada 17/18.

📋 Selección de columnas

Seleccionamos sólo las columnas de interés:

columns <- c(  "Date"
             , "HomeTeam" 
             , "AwayTeam"
             , "FTHG"
             , "FTAG"
             , "FTR"
             )

temporadas %<>% lapply(select, all_of(columns))

📋 Corrección y Unión de datos

Revisamos que las columnas sean del mismo tipo, corregimos el error de formato y tipo de dato de la columna Date y unimos en un solo data frame:

data <- temporadas %>% unname %>% do.call(rbind, .)
# Corrección del formato de fecha usando una expresión regular
data %<>% mutate(Date = gsub("/(1[78])$", "/20\\1", Date))  
# Correccioón del tipo de dato
data %<>% mutate(Date = as.Date(Date, "%d/%m/%Y"))

head(data$Date)
## [1] "2017-08-18" "2017-08-18" "2017-08-19" "2017-08-19" "2017-08-19"
## [6] "2017-08-20"
#data frame final solo con los datos elegidos
(dim(data))
## [1] 1140    6

📋 Escritura de archivo corregido

Guardamos el data frame obtenido en formato csv en una carpeta llamada “equipo10”:

w.dir   <- getwd()
sub.dir <- "equipo10"
path    <- file.path(w.dir, sub.dir)
dir.create(path, showWarnings = F, recursive = T)
setwd(path)

#guardamos el df en un archivo csv
write.csv(data, file = 'Postwork_02.csv', row.names = FALSE)
setwd(w.dir)

📂 POSTWORK 3

Importamos las bibliotecas:

library(ggplot2)
library(plotly)
library(dplyr)
library(ggplot2)
library(viridis)
library(viridisLite)

Con el data frame obtenido realizaremos algunas gráficas.

data <- "https://raw.githubusercontent.com/napoleonleal/R-BEDU-Project/main/Postwork_2/Postwork_02.csv" %>%
        read.csv %>% 
        mutate(Date = as.Date(Date, "%Y-%m-%d"))

📋 Local: Probabilidad Marginal

Calcularemos la probabilidad marginal de que el equipo local anote ’x’ goles mediante una función previa:

prob.m.local <- 
  get.prob.df(data, FTHG, "Gol.Home", "P.Marginal") 

(prob.m.local %>% get.round(3))
##   Gol.Home Freq P.Marginal
## 1        0  265      0.232
## 2        1  373      0.327
## 3        2  304      0.267
## 4        3  128      0.112
## 5        4   40      0.035
## 6        5   22      0.019
## 7        6    6      0.005
## 8        7    1      0.001
## 9        8    1      0.001

🔢 plot.bar()

Realizamos una función de una gráfica para vizualizar los datos:

plot.bar <- function(data, x.lab, y.lab, f.lab, title){
  Goles         <- data[1] %>% unlist()
  Porcentaje    <- (data[3]*100 ) %>% unlist %>% round(., digits=2)
  Prob.Marginal <- data[3] %>% unlist() %>% round(., digits=4)
  data %>%
  ggplot() +
  geom_bar(stat = 'identity') +
  aes(  x = Goles
      , y = Porcentaje
      , fill = Porcentaje
      , text = paste("Prob Marginal", Prob.Marginal)
                      #, group = interaction(Goles, Porcentaje)
       ) +
  labs(  x     = x.lab
       , y     = y.lab
       , fill  = f.lab
       , title = title
       ) +
  theme_minimal() +
  theme(  text = element_text(size=15)
        , legend.title = element_text(size=10) 
        ) +
  scale_fill_viridis(name=f.lab, direction = 1) 
}

Realizamos una gráfica para vizualizar los datos:

plot.local <- plot.bar(prob.m.local
              , "Goles [n]"
              , "Probabilidad de ocurrencia [%]"
              , "%"
              , "Probabilidad de anotación del equipo local"
              )

📊 Local: P(x) Marginal

ggplotly(plot.local) #versión interactiva

📋 Visitante: Probabilidad Marginal

Ahora calcularemos la probabilidad para el equipo visitante:

prob.m.visit <- 
  get.prob.df(data, FTAG, "Gol.Away", "P.Marginal") 
 
(prob.m.visit %>% get.round(3))
##   Gol.Away Freq P.Marginal
## 1        0  401      0.352
## 2        1  388      0.340
## 3        2  242      0.212
## 4        3   62      0.054
## 5        4   33      0.029
## 6        5   11      0.010
## 7        6    3      0.003

Realizamos una gráfica para vizualizar los datos:

plot.visit <- plot.bar(prob.m.visit
              , "Goles [n]"
              , "Probabilidad de ocurrencia [%]"
              , "%"
              , "Probabilidad de anotación del equipo visitante"
              )

📊 Visitante: P(y) Marginal

ggplotly(plot.visit) #versión interactiva

📋 Probabilidad Conjunta P(x∩y)

La probabilidad conjunta de que el equipo que juega en casa anote ‘x’ goles y el equipo que juega como visitante anote ’y’ goles calculada con una función previa:

prob.joint <- 
  get.prob.joint.tbl(data, data$FTHG, data$FTAG, "Local", "Visitante") 

(prob.joint  %<>% "*"(100) %>% round(2))
##      Visitante
## Local     0     1     2     3     4     5     6
##     0  7.81  8.07  4.56  1.84  0.53  0.44  0.00
##     1 11.58 11.49  6.84  1.75  0.88  0.18  0.00
##     2  8.77  9.39  6.14  1.14  0.88  0.18  0.18
##     3  4.47  3.25  2.46  0.61  0.18  0.18  0.09
##     4  1.40  1.05  0.70  0.00  0.35  0.00  0.00
##     5  0.88  0.53  0.44  0.00  0.09  0.00  0.00
##     6  0.26  0.18  0.00  0.09  0.00  0.00  0.00
##     7  0.00  0.09  0.00  0.00  0.00  0.00  0.00
##     8  0.00  0.00  0.09  0.00  0.00  0.00  0.00

Realizamos un heat map con una función para visualizar los datos:

prob.joint %<>% as.data.frame() %>% rename(Probabilidad = Freq)

🔢 plot.heatmap()

plot.heatmap <- function(data, x.lab, y.lab, f.lab, title){
  Local         <- data[1] %>% unlist
  Visitante     <- data[2] %>% unlist
  Probabilidad  <- data[3] %>% unlist
    ggplot(data) +
    aes(   Local
         , Visitante
         , fill = Probabilidad
         ) + #gráficamos
    geom_raster() +
    labs(  x     = x.lab
         , y     = y.lab
         , fill  = f.lab
         , title = title
         ) +
    theme(  text = element_text(size=18)
          , legend.title = element_text(size=15) 
          ) +
    scale_fill_viridis(  name=f.lab
                       , direction = 1 #, option = "H"
                       ) 
}

Realizamos una gráfica para visualizar los datos:

plot.mapa.calor <-
plot.heatmap(  prob.joint
             , "Local [goles]"
             , "Visitante [goles]"
             , "Probabilidad [%]"
             , "Probabilidad Conjunta de anotación"
             )

📊 Heat Map P(x∩y) Conjunta

ggplotly(plot.mapa.calor)    #versión interactiva

📂 POSTWORK 4

Ahora obtendremos una tabla de cocientes al dividir las probabilidades conjuntas por el producto de las probabilidades correspondientes:

\[Cocientes = \dfrac{P\left(x \cap y\right)_{conjunta}} {P\left(x\right)_{marginal} P\left(y\right)_{marginal}} \]

data <- read.csv("https://raw.githubusercontent.com/napoleonleal/R-BEDU-Project/main/Postwork_02.csv")

📋 Probabilidad Marginal

Para la probabilidad marginal de los goles metidos por locales con una función previa:

prob.m.local <- get.prob.df(data, FTHG, "Gol.Home", "Prob.Marginal") 

(prob.m.local %>% get.round(3))
##   Gol.Home Freq Prob.Marginal
## 1        0  363         0.239
## 2        1  503         0.331
## 3        2  402         0.264
## 4        3  157         0.103
## 5        4   59         0.039
## 6        5   27         0.018
## 7        6    7         0.005
## 8        7    1         0.001
## 9        8    1         0.001

Para los goles metidos por el equipo visitante:

prob.m.visit <- get.prob.df(data, FTAG, "Gol.Away", "Prob.Marginal") 

(prob.m.visit %>% get.round(3))
##   Gol.Away Freq Prob.Marginal
## 1        0  516         0.339
## 2        1  540         0.355
## 3        2  315         0.207
## 4        3   90         0.059
## 5        4   43         0.028
## 6        5   12         0.008
## 7        6    4         0.003

📋 Producto de Probabilidades Marginales

Hacemos el producto de las probabilidades marginales obtenidas con una función previa:

tbl.local <- get.prob.m.tbl(data, FTHG, "Home")
tbl.visit <- get.prob.m.tbl(data, FTAG, "Away")

product.prob.m <- tbl.local %o% tbl.visit

(product.prob.m %>% round(3))
##     Away
## Home     0     1     2     3     4     5     6
##    0 0.081 0.085 0.049 0.014 0.007 0.002 0.001
##    1 0.112 0.118 0.069 0.020 0.009 0.003 0.001
##    2 0.090 0.094 0.055 0.016 0.007 0.002 0.001
##    3 0.035 0.037 0.021 0.006 0.003 0.001 0.000
##    4 0.013 0.014 0.008 0.002 0.001 0.000 0.000
##    5 0.006 0.006 0.004 0.001 0.001 0.000 0.000
##    6 0.002 0.002 0.001 0.000 0.000 0.000 0.000
##    7 0.000 0.000 0.000 0.000 0.000 0.000 0.000
##    8 0.000 0.000 0.000 0.000 0.000 0.000 0.000

📋 Probabilidad Conjunta P(x∩y)

Obtenemos la probabilidad conjunta con una función previa:

prob.conjunta <-
  get.prob.joint.tbl(data, data$FTHG, data$FTAG, "Home", "Away")

(prob.conjunta %>% round(3))
##     Away
## Home     0     1     2     3     4     5     6
##    0 0.078 0.083 0.051 0.018 0.006 0.003 0.000
##    1 0.112 0.123 0.062 0.022 0.009 0.002 0.001
##    2 0.086 0.097 0.060 0.012 0.008 0.001 0.001
##    3 0.039 0.032 0.022 0.006 0.003 0.001 0.001
##    4 0.015 0.013 0.007 0.001 0.003 0.000 0.000
##    5 0.007 0.005 0.005 0.000 0.001 0.000 0.000
##    6 0.002 0.002 0.000 0.001 0.000 0.000 0.000
##    7 0.000 0.001 0.000 0.000 0.000 0.000 0.000
##    8 0.000 0.000 0.001 0.000 0.000 0.000 0.000

📋 Cociente de Probabilidades

Realizamos el cociente:

cociente <- prob.conjunta/product.prob.m

(cociente %>% round(2))
##     Away
## Home    0    1    2    3    4    5    6
##    0 0.97 0.98 1.02 1.26 0.88 1.74 0.00
##    1 1.00 1.05 0.91 1.14 0.91 0.76 0.76
##    2 0.95 1.03 1.09 0.76 1.06 0.63 1.89
##    3 1.13 0.86 1.01 0.97 0.90 1.61 2.42
##    4 1.15 0.95 0.90 0.29 2.40 0.00 0.00
##    5 1.20 0.83 1.25 0.00 1.31 0.00 0.00
##    6 1.26 1.21 0.00 2.41 0.00 0.00 0.00
##    7 0.00 2.81 0.00 0.00 0.00 0.00 0.00
##    8 0.00 0.00 4.83 0.00 0.00 0.00 0.00

📋 Bootstrap

Para determinar si el número de goles del equipo local o el de el equipo visitante son dependientes o independientes, realizaremos un procedimiento de bootstrap para obtener más cocientes similares y analizar la distribución.

Transformamos el data frame a columna para facilitar el bootstrap.

data_origin <- as.data.frame(as.vector(unlist(cociente)))

colnames(data_origin) <- "values"

Utilizamos la biblioteca "rsample" para poder hacer las muestras bootstrap:

library(rsample)

Fijamos la semilla para poder reproducir los datos:

set.seed(83928782)

🔢 bootstraps() rsample

Aplicamos la función bootstraps, para generar 1000 muestras, guardándolas en boot:

boot <- bootstraps(data_origin, times = 1000)

Cargamos las siguientes bibliotecas para visualizar datos:

library(purrr)
library(modeldata)
library(viridis)
library(tidyverse)
library(hrbrthemes)
library(forcats)
library(viridisLite)

Realizamos una función para hacer una columna de las medias muestrales obtenidas por bootstrap:

obtener_media <- function(boot_splits) {
  data_mean         <- analysis(boot_splits)
  medias_muestrales <- mean(data_mean[,1])
  return(medias_muestrales)
}

📋 Medias Muestrales

Observamos el valor de la media de las medias muestrales tras aplicar la función:

boot$means <- map_dbl(boot$splits, obtener_media)

length(boot$means); summary(boot$means)
## [1] 1000
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##  0.4996  0.7523  0.8256  0.8288  0.9048  1.1796

📋 Intervalos de confianza

Comprobamos la hipótesis de que la media se encuentra en 1 con las medias muestrales bootstrap y obtenemos el intervalo de confianza al 95% con una prueba t:

t_boot    <- t.test(boot$means, alternative = "two.sided", mu = 1)
t_boot_ic <- round(t_boot$conf.int,3)
t_boot_ic
## [1] 0.822 0.835
## attr(,"conf.level")
## [1] 0.95

🔢 plot.histogram()

Realizamos una función para un histograma:

plot.histogram <- function(  data, data_mean, ic_2, n_bins
                           , title, x.lab, y.lab, f.lab ){
    ggplot(data) +
    geom_histogram(  bins = n_bins
                   , color=NA
                   , aes(fill=..count..)
                   ) + 
    aes(data_mean) + 
    labs(  x     = x.lab
         , y     = y.lab
         , fill  = f.lab
         , title = title
         ) +
    geom_vline(
                aes( xintercept = mean(data_mean))
                ) +
    geom_vline(  xintercept = c(ic_2), ####
                 linetype = c(2,2)
                 ) +
    scale_fill_viridis(name = f.lab) +
    theme_minimal() +
    #theme_ipsum() +
    theme(  text = element_text(size=18)
          , legend.title = element_text(size=15) 
          , panel.spacing = unit(0.1, "lines")
          , strip.text.x = element_text(size = 10)
          #legend.position="none",
    )
}

Realizamos el histograma de las medias muestrales obtenidas por bootstrap.

ic_mean_ic <- c(t_boot_ic[1], 
                mean(boot$means), 
                t_boot_ic[2])

hist_boot <- 
  plot.histogram(  boot
               , boot$means
               , t_boot_ic
               , 18
               , paste("Histograma de las medias muestrales bootstrap"
                       , "\n<i><b>n="
                       , length(boot$means)
                       , "</b></i>"
                       , sep = ""
                       )
               , "Valor de la Media"
               , "Frecuencia"
               , "Frec"
  )

📊 Histograma medias bootstrap

ggplotly(hist_boot)

La línea sólida indica la posición de la media y las punteadas, la posición de los límites del intervalo de confianza.

De igual modo lo hacemos para la muestra original:

t_origin <- t.test(data_origin$values, alternative = "two.sided", mu = 1)
t_origin_ic <- t_origin$conf.int %>% round(3)
t_origin_ic
## [1] 0.613 1.053
## attr(,"conf.level")
## [1] 0.95
ori_ic_mean_ic <- c(t_origin_ic[1], 
                    mean(data_origin$values), 
                    t_origin_ic[2])

hist_origin <- 
      plot.histogram(  data_origin
                 , data_origin$values
                 , t_origin_ic
                 , 11
                 , "Histograma de la muestra original"
                 , "Valor de la Muestra"
                 , "Frecuencia"
                 , "Frec"
                 )

📊 Histograma original

ggplotly(hist_origin)

La línea sólida indica la posición de la media y las punteadas, la posición de los límites del intervalo de confianza.

📋 Pruebas t

Vemos los datos de los estadísticos de las pruebas t para ambos conjuntos de datos.

Remuestreo bootstrap:

t_boot
## 
##  One Sample t-test
## 
## data:  boot$means
## t = -50.464, df = 999, p-value < 2.2e-16
## alternative hypothesis: true mean is not equal to 1
## 95 percent confidence interval:
##  0.8221057 0.8354231
## sample estimates:
## mean of x 
## 0.8287644

Muestras originales:

t_origin
## 
##  One Sample t-test
## 
## data:  data_origin$values
## t = -1.5194, df = 62, p-value = 0.1338
## alternative hypothesis: true mean is not equal to 1
## 95 percent confidence interval:
##  0.6130959 1.0527411
## sample estimates:
## mean of x 
## 0.8329185

🏁 Conclusiones

📂 POSTWORK 5

Con los datos de la liga de primera división española, de las temporadas 2017/2018, 2018/2019 y 2019/2020 haremos una predicción de los resultados de los partidos de la fecha 07/16/2020.

Utilizamos la librería dplyr para manipulaciín de datos:

library(dplyr)

Y la librería fbRanks para las predicciones en base al modelo de Dixon y Coles:

library(fbRanks)

📋 Escribir soccer.csv

Guardamos los datos de las 3 temporadas en una lista. Seleccionamos unicamente los elementos “Date”, “HomeTeam”, “FTHG”, “AwayTeam” ,“FTAG”, los cuales son esenciales para el modelo y cambiamos los nombres de las columnas por requerimiento de la biblioteca. Unimos las 3 temporadas en una sola y Cambiamos la forma del año, para poder aplicar un único formato date:

columns <- c(  date       = "Date"
             , home.team  = "HomeTeam" 
             , away.team  = "AwayTeam"
             , home.score = "FTHG"
             , away.score = "FTAG"
             )

SmallData <-
    c( "https://www.football-data.co.uk/mmz4281/1718/SP1.csv"
     , "https://www.football-data.co.uk/mmz4281/1819/SP1.csv"
     , "https://www.football-data.co.uk/mmz4281/1920/SP1.csv"
     ) %>% 
        lapply (read.csv)                     %>%
        lapply (select, all_of(columns))      %>% 
        do.call(rbind, .)                     %>% 
        mutate (date = gsub("/(1[78])$", 
                            "/20\\1", date))  %>%
        mutate (date = as.Date(date, "%d/%m/%Y"))

Guardamos los cambios en un archivo csv:

w.dir   <- getwd()
sub.dir <- "equipo10"
path    <- file.path(w.dir, sub.dir)
dir.create(path, showWarnings = F, recursive = T)
setwd(path)

write.csv(SmallData, file = './soccer.csv', row.names = F)
setwd(w.dir)

📋 fbRanks: anotaciones y equipos

Aplicamos la primera función de la biblioteca, “create.fbranks.dataframes” con la finalidad de poder hacer una limpieza de datos, excluyendo los datos nulos para las puntuaciones, así como nombres repetidos, los cambios incluyen la transformación del formato de columna “date”:

listasoccer <- create.fbRanks.dataframes(scores.file = "soccer.csv")
## Alert: teams info file was not passed in.
## Will construct one from the scores data frame but teams in the scores file must use a unique name.
## Alert: teams resolver was not passed in.
## Will construct one from the team info data frame.
(listasoccer)
## $scores
##            date   home.team   away.team home.score away.score
## 1    2017-08-18     Leganes      Alaves          1          0
## 2    2017-08-18    Valencia  Las Palmas          1          0
## 3    2017-08-19       Celta    Sociedad          2          3
## 4    2017-08-19      Girona  Ath Madrid          2          2
## 5    2017-08-19     Sevilla     Espanol          1          1
## 6    2017-08-20  Ath Bilbao      Getafe          0          0
## 7    2017-08-20   Barcelona       Betis          2          0
## 8    2017-08-20   La Coruna Real Madrid          0          3
...

Como residuo, la función nos devuelve una lista con un data.frame scores con los datos de nuestro csv limpios y las fechas en orden ascendente, como también el data frame teams, en este caso generado del csv, con los nombres de los equipos sin repetir, el data.frame teams.resolver y por último el data.frame raw.scores, con algunas configuraciones para el uso de otras funciones.

View(listasoccer)

Guardamos el data.frame scores generados, con las puntuaciones en las temporadas

anotaciones = listasoccer$scores

Guardamos la lista de equipos

equipos = listasoccer$teams

📋 Ranking de Equipos

Guardamos las fechas sin repetir

fecha = unique(listasoccer$scores$date)

Y la cantidad de las fechas para un mejor control

n = length(fecha)

Aplicamos la función “rank.teams”, el cual aplica una regresión lineal usando como modelo la distribución de Poisson, tomando como rango de tiempo la duración de un partido.

La función requiere los datos scores, la lista de equipos y las fechas entre las que generamos nuestro ranking

ranking = rank.teams(  anotaciones
                     , equipos
                     , max.date = fecha[n-1]
                     , min.date = fecha[1]
                     , date.format = "%Y-%m-%d")
## 
## Team Rankings based on matches 2017-08-18 to 2020-07-16
##    team        total attack defense n.games.Var1 n.games.Freq
## 1  Barcelona    1.51 2.23   1.28    Barcelona    113         
## 2  Ath Madrid   1.24 1.33   1.78    Ath Madrid   113         
## 3  Real Madrid  1.15 1.86   1.19    Real Madrid  113         
## 4  Valencia     0.56 1.34   1.10    Valencia     113         
## 5  Getafe       0.55 1.10   1.33    Getafe       113         
## 6  Sevilla      0.43 1.37   0.98    Sevilla      113         
## 7  Granada      0.37 1.26   1.03    Granada       37         
...

Como resultado nos da una lista con las especificaciones que le dimos a nuestra función Y nos presenta una tabla ranking, con los coeficientes de la regresión, tanto de ataque y defensa, modificados para su mejor comprensión, y uniéndolos en un total, posicionando a los equipos con base en el total.

(ranking)
## 
## Team Rankings based on matches 2017-08-18 to 2020-07-16
##    team        total attack defense n.games.Var1 n.games.Freq
## 1  Barcelona    1.51 2.23   1.28    Barcelona    113         
## 2  Ath Madrid   1.24 1.33   1.78    Ath Madrid   113         
## 3  Real Madrid  1.15 1.86   1.19    Real Madrid  113         
## 4  Valencia     0.56 1.34   1.10    Valencia     113         
## 5  Getafe       0.55 1.10   1.33    Getafe       113         
## 6  Sevilla      0.43 1.37   0.98    Sevilla      113         
## 7  Granada      0.37 1.26   1.03    Granada       37         
...

La función da como resultado una clase única de la librería “fbRanks” necesaria para el uso de otras funciones

class(ranking)
## [1] "fbRanks"

En la lista “ranking” es posible encontrar los coeficientes de la regresión en crudo, como sus especificaciones

ranking[1]
## $fit
## $fit$cluster.1
## 
## Call:  glm(formula = as.formula(my.formula), family = family, weights = exp(-1 * 
##     time.weight.eta * time.diff), na.action = "na.exclude")
## 
## Coefficients:
##      attackAlaves   attackAth Bilbao   attackAth Madrid    attackBarcelona  
##         0.0494074          0.1262803          0.3912525          0.9066502  
##       attackBetis        attackCelta        attackEibar      attackEspanol  
...
View(ranking[1])

Podemos extraer los datos de la función rank

columns = c(  team    = "ranks.team"
            , total   = "ranks.total"
            , attack  = "ranks.attack"
            , defense = "ranks.defense"
            , n.games.Var1 = "ranks.n.games.Var1"
            , n.games.Freq = "ranks.n.games.Freq"
            )
Ranking.datos <-
    ranking %>% 
    print   %>% 
    as.data.frame %>% 
    select(all_of(columns))
## 
## Team Rankings based on matches 2017-08-18 to 2020-07-16
##    team        total attack defense n.games.Var1 n.games.Freq
## 1  Barcelona    1.51 2.23   1.28    Barcelona    113         
## 2  Ath Madrid   1.24 1.33   1.78    Ath Madrid   113         
## 3  Real Madrid  1.15 1.86   1.19    Real Madrid  113         
## 4  Valencia     0.56 1.34   1.10    Valencia     113         
## 5  Getafe       0.55 1.10   1.33    Getafe       113         
## 6  Sevilla      0.43 1.37   0.98    Sevilla      113         
## 7  Granada      0.37 1.26   1.03    Granada       37         
...

y aprovecharlos para hacer diversos análisis teniéndolos en formato csv ya exportado.

Ranking.datos <- read.csv("https://raw.githubusercontent.com/napoleonleal/R-BEDU-Project/main/ranking20.csv")

Basándonos en nuestro modelo, podemos ver el máximo atacante, y el máximo defensor

(Max.atacante <- Ranking.datos %>% filter(attack  == max(attack)))
##        team total attack defense n.games.Var1 n.games.Freq
## 1 Barcelona  1.51   2.23    1.28    Barcelona          113
(Max.defensor <- Ranking.datos %>% filter(defense == max(defense)))
##         team total attack defense n.games.Var1 n.games.Freq
## 1 Ath Madrid  1.24   1.33    1.78   Ath Madrid          113

Como también el resumen

summary(Ranking.datos)
##      team               total              attack          defense      
##  Length:26          Min.   :-1.43000   Min.   :0.5800   Min.   :0.6000  
##  Class :character   1st Qu.:-0.32500   1st Qu.:0.9675   1st Qu.:0.7875  
##  Mode  :character   Median : 0.00000   Median :1.0950   Median :0.9050  
##                     Mean   : 0.02885   Mean   :1.1600   Mean   :0.9442  
##                     3rd Qu.: 0.36000   3rd Qu.:1.3175   3rd Qu.:1.0225  
##                     Max.   : 1.51000   Max.   :2.2300   Max.   :1.7800  
##                                                                         
##       n.games.Var1  n.games.Freq   
##  Barcelona  : 1    Min.   : 37.00  
...

📋 Predicción Última Fecha

Para las predicciones referentes a los últimos partidos de la liga, utilizaremos la función “predict”, que se basa en el modelo de Dixon and Coles, el cual es una modificación del modelo de predicciones de distribuciones de Poisson, con una modificación en cuanto a la sobre-estimación de los datos fuera de la media.

La función requiere un objeto clase “fbRank”, ya que hace uso de los coeficientes de la regresión lineal.

prediccion = predict.fbRanks(ranking, date = fecha[n])
## Predicted Match Results for 1900-05-01 to 2100-06-01
## Model based on data from 2017-08-18 to 2020-07-16
## ---------------------------------------------
## 2020-07-19 Alaves vs Barcelona, HW 9%, AW 76%, T 16%, pred score 0.7-2.5  actual: AW (0-5)
## 2020-07-19 Valladolid vs Betis, HW 29%, AW 43%, T 28%, pred score 1-1.3  actual: HW (2-0)
## 2020-07-19 Villarreal vs Eibar, HW 45%, AW 30%, T 25%, pred score 1.5-1.2  actual: HW (4-0)
## 2020-07-19 Ath Madrid vs Sociedad, HW 54%, AW 20%, T 26%, pred score 1.5-0.8  actual: T (1-1)
## 2020-07-19 Espanol vs Celta, HW 32%, AW 41%, T 27%, pred score 1.2-1.4  actual: T (0-0)
## 2020-07-19 Granada vs Ath Bilbao, HW 40%, AW 31%, T 29%, pred score 1.2-1  actual: HW (4-0)
## 2020-07-19 Leganes vs Real Madrid, HW 13%, AW 66%, T 21%, pred score 0.7-1.9  actual: T (2-2)
...

La función regresa una lista, con data.frames y vectores, nos enfocaremos principalmente en su primer objeto “scores”, a diferencia de nuestro csv, solo contiene los datos sobre los últimos partidos, dando como información las probabilidades de victoria, derrota, empate victoria-derrota con 0 goles del rival, ademas de incluir los coeficientes de la regresión

View(prediccion[1])

Centrándonos en las probabilidades de victoria, derrota, empate para el equipo de local como también la predicción del número de goles redondeada:

columns <-
c(  Home.team      = "home.team"
  , Away.team      = "away.team"
  , Prob.win.home  = "home.win"
  , Prob.win.away  = "away.win"
  , Prob.tie       = "tie"
  , Pred.home.score = "pred.home.score"
  , Pred.away.score = "pred.away.score"
  )

predict.prob <-
  prediccion$scores %>% as.data.frame %>% select(all_of(columns)) %>% 
      mutate(  Pred.home.score = Pred.home.score %>% round(0)
             , Pred.away.score = Pred.away.score %>% round(0))

(predict.prob)
##       Home.team   Away.team Prob.win.home Prob.win.away Prob.tie
## 1131     Alaves   Barcelona         8.814        75.668   15.518
## 1132 Valladolid       Betis        28.672        43.066   28.262
## 1133 Villarreal       Eibar        44.932        29.754   25.314
## 1134 Ath Madrid    Sociedad        53.669        19.958   26.373
## 1135    Espanol       Celta        31.949        41.429   26.622
## 1136    Granada  Ath Bilbao        39.629        31.135   29.236
## 1137    Leganes Real Madrid        12.720        66.207   21.073
## 1138    Levante      Getafe        25.172        47.890   26.938
## 1139    Osasuna    Mallorca        47.992        27.228   24.780
...

Hacemos una comparación con los datos reales:

columns <-
c(  Home.team           = "home.team"
  , Home.score          = "home.score"
  , Pred.home.score     = "pred.home.score"
  , Away.team           = "away.team"
  , Away.score          = "away.score"
  , Pred.away.score     = "pred.away.score"
  )

   
comparacion <-
    prediccion$scores %>% as.data.frame %>% select(all_of(columns)) %>% 
      mutate(  Pred.home.score = Pred.home.score %>% round(0)
             , Pred.away.score = Pred.away.score %>% round(0))

Los partidos en los cuales acertó el número de goles del equipo de local

(comparacion %>% filter(Home.score == Pred.home.score))
##    Home.team Home.score Pred.home.score Away.team Away.score Pred.away.score
## 1 Ath Madrid          1               1  Sociedad          1               1
## 2    Levante          1               1    Getafe          0               1
## 3    Osasuna          2               2  Mallorca          2               1
## 4    Sevilla          1               1  Valencia          0               1

Y en donde acertó los goles del equipo visitante

(comparacion %>% filter(Away.score == Pred.away.score))
##    Home.team Home.score Pred.home.score   Away.team Away.score Pred.away.score
## 1 Ath Madrid          1               1    Sociedad          1               1
## 2    Leganes          2               1 Real Madrid          2               2

📋 Matriz de Confusión

Hacemos la predicción de todas las fechas de los partidos usando el objeto ranking y obtenemos la matriz de confusión donde las clases son el número de goles

prediccion.total.partidos = predict.fbRanks(ranking, date = fecha)
## Predicted Match Results for 1900-05-01 to 2100-06-01
## Model based on data from 2017-08-18 to 2020-07-16
## ---------------------------------------------
## 2017-08-18 Leganes vs Alaves, HW 33%, AW 35%, T 32%, pred score 0.9-1  actual: HW (1-0)
## 2017-08-18 Valencia vs Las Palmas, HW 75%, AW 8%, T 17%, pred score 2.1-0.5  actual: HW (1-0)
## 2017-08-19 Celta vs Sociedad, HW 32%, AW 45%, T 23%, pred score 1.4-1.7  actual: AW (2-3)
## 2017-08-19 Girona vs Ath Madrid, HW 14%, AW 62%, T 25%, pred score 0.6-1.6  actual: T (2-2)
## 2017-08-19 Sevilla vs Espanol, HW 49%, AW 24%, T 26%, pred score 1.5-0.9  actual: T (1-1)
## 2017-08-20 Ath Bilbao vs Getafe, HW 27%, AW 40%, T 33%, pred score 0.8-1  actual: T (0-0)
## 2017-08-20 Barcelona vs Betis, HW 74%, AW 11%, T 15%, pred score 2.8-1  actual: HW (2-0)
...
columns <-
c(  Home.team           = "home.team"
  , Home.score          = "home.score"
  , Pred.home.score     = "pred.home.score"
  , Away.team           = "away.team"
  , Away.score          = "away.score"
  , Pred.away.score     = "pred.away.score"
  )

comparacion.total.partidos <-
    prediccion.total.partidos$scores %>% as.data.frame %>% select(all_of(columns)) %>% 
      mutate(  Pred.home.score = Pred.home.score %>% round(0)
             , Pred.away.score = Pred.away.score %>% round(0))
library(caret)
library(lattice)

Matriz de confusión de la predicción de los goles locales

confusion.m.local <-
    confusionMatrix(  factor(  comparacion.total.partidos$Pred.home.score
                             , levels = 0:max(comparacion.total.partidos$Home.score))
                    , factor(  comparacion.total.partidos$Home.score
                             , levels = 0:max(comparacion.total.partidos$Home.score))
                    , dnn = c("Prediccion", "Valores Reales"))

(confusion.m.local)
## Confusion Matrix and Statistics
## 
##           Valores Reales
## Prediccion   0   1   2   3   4   5   6   7   8
##          0   8   4   1   0   0   0   0   0   0
##          1 226 305 210  78  19   4   1   0   0
##          2  31  61  86  44  19  16   4   0   0
##          3   0   3   7   5   1   2   1   1   1
##          4   0   0   0   1   1   0   0   0   0
##          5   0   0   0   0   0   0   0   0   0
##          6   0   0   0   0   0   0   0   0   0
##          7   0   0   0   0   0   0   0   0   0
##          8   0   0   0   0   0   0   0   0   0
## 
## Overall Statistics
##                                           
##                Accuracy : 0.3553          
##                  95% CI : (0.3274, 0.3838)
##     No Information Rate : 0.3272          
##     P-Value [Acc > NIR] : 0.02395         
##                                           
##                   Kappa : 0.0686          
##                                           
##  Mcnemar's Test P-Value : NA              
## 
## Statistics by Class:
## 
##                      Class: 0 Class: 1 Class: 2 Class: 3  Class: 4 Class: 5
## Sensitivity          0.030189   0.8177  0.28289 0.039062 0.0250000   0.0000
## Specificity          0.994286   0.2986  0.79067 0.984190 0.9990909   1.0000
## Pos Pred Value       0.615385   0.3618  0.32950 0.238095 0.5000000      NaN
## Neg Pred Value       0.771961   0.7710  0.75199 0.890080 0.9657293   0.9807
## Prevalence           0.232456   0.3272  0.26667 0.112281 0.0350877   0.0193
## Detection Rate       0.007018   0.2675  0.07544 0.004386 0.0008772   0.0000
## Detection Prevalence 0.011404   0.7395  0.22895 0.018421 0.0017544   0.0000
## Balanced Accuracy    0.512237   0.5581  0.53678 0.511626 0.5120455   0.5000
##                      Class: 6  Class: 7  Class: 8
## Sensitivity          0.000000 0.0000000 0.0000000
## Specificity          1.000000 1.0000000 1.0000000
## Pos Pred Value            NaN       NaN       NaN
## Neg Pred Value       0.994737 0.9991228 0.9991228
## Prevalence           0.005263 0.0008772 0.0008772
## Detection Rate       0.000000 0.0000000 0.0000000
## Detection Prevalence 0.000000 0.0000000 0.0000000
## Balanced Accuracy    0.500000 0.5000000 0.5000000

Vemos que la exactitud (accuracy), que es la cantidad de predicciones positivas que fueron correctas y que esta dada por la suma de la diagonal entre la suma total, es de 35.53%. El modelo acertó en el 35.53% de su predicción.

Además se aprecia la relación entre los valores predecidos y los reales.

En la sensibilidad (sensitivity), que es la proporción de casos positivos que fueron correctamente identificados, vemos que el valor más alto es cuando predice que el equipo local anota 1 gol. El modelo acertó en el 81.77% de las anotaciones reales que fueron de 1 gol.

Al ver la distribución de la matriz notamos que el modelo no acertó la predicción en ningún valor de 5 a 8 goles. Ni siquiera hubo esos valores en su predicción.

Y el “Pos Pred Value” es la proporción de predicciones correctamente identificadas del total de predicciones para cada clase. De todos los marcadores con gol 0 que predijo, el 61.53% fue acertado. Los demas están por abajo del 50%.

Matriz de confusión de la predicción de los goles del visitante

confusion.m.visit <-
    confusionMatrix(  factor(  comparacion.total.partidos$Pred.away.score
                             , levels = 0:max(comparacion.total.partidos$Away.score)
                             )
                    , factor(  comparacion.total.partidos$Away.score
                             , levels = 0:max(comparacion.total.partidos$Away.score))
                    , dnn = c("Prediccion", "Valores Reales"))

(confusion.m.visit)
## Confusion Matrix and Statistics
## 
##           Valores Reales
## Prediccion   0   1   2   3   4   5   6
##          0  12   0   1   0   0   0   0
##          1 336 299 155  39  10   4   0
##          2  49  86  81  18  19   5   3
##          3   4   2   5   5   3   2   0
##          4   0   1   0   0   1   0   0
##          5   0   0   0   0   0   0   0
##          6   0   0   0   0   0   0   0
## 
## Overall Statistics
##                                           
##                Accuracy : 0.3491          
##                  95% CI : (0.3214, 0.3776)
##     No Information Rate : 0.3518          
##     P-Value [Acc > NIR] : 0.5848          
##                                           
##                   Kappa : 0.063           
##                                           
##  Mcnemar's Test P-Value : NA              
## 
## Statistics by Class:
## 
##                      Class: 0 Class: 1 Class: 2 Class: 3  Class: 4 Class: 5
## Sensitivity           0.02993   0.7706  0.33471 0.080645 0.0303030 0.000000
## Specificity           0.99865   0.2766  0.79955 0.985158 0.9990967 1.000000
## Pos Pred Value        0.92308   0.3547  0.31034 0.238095 0.5000000      NaN
## Neg Pred Value        0.65484   0.7003  0.81684 0.949062 0.9718805 0.990351
## Prevalence            0.35175   0.3404  0.21228 0.054386 0.0289474 0.009649
## Detection Rate        0.01053   0.2623  0.07105 0.004386 0.0008772 0.000000
## Detection Prevalence  0.01140   0.7395  0.22895 0.018421 0.0017544 0.000000
## Balanced Accuracy     0.51429   0.5236  0.56713 0.532901 0.5146998 0.500000
##                      Class: 6
## Sensitivity          0.000000
## Specificity          1.000000
## Pos Pred Value            NaN
## Neg Pred Value       0.997368
## Prevalence           0.002632
## Detection Rate       0.000000
## Detection Prevalence 0.000000
## Balanced Accuracy    0.500000

Vemos que la exactitud (accuracy) es de 34.91%. El modelo acertó en el 34.91% de su predicción.

En la sensibilidad (sensitivity) vemos que el valor más alto es cuando predice que el equipo visitante anota 1 gol. El modelo acertó en el 77.06% de las anotaciones reales que fueron de 1 gol.

Al ver la distribución de la matriz notamos que el modelo no acertó la predicción en ningún valor de 5 y 6 goles. Ni siquiera hubo esos valores en su predicción.

Y en el “Pos Pred Value” vemos que de todos los marcadores con gol 0 que predijo, el 92.30% fue acertado. Los demas están por en el 50% o debajo.

🏁 Conclusiones

En las últimas comparaciones de las predicciones hechas por la librería fbRanks podemos notar que la predicción en cuanto el número de goles debe tomarse con mucho cuidado, esto ya que por ejemplo en el partido jugado por Barcelona, en el partido éste anotó 5 goles, estos casos son muy poco probables, más si es usado el modelo de Dixon y Coles, ya que reduce la posible sobre-estimación de estos casos, debido a su rareza, de 10 partidos acertó totalmente en 1 partido, por lo que estos análisis pueden servir como referencia, pero la predicción de resultados de juegos puede ser muy compleja, por el número de factores involucrados.

📂 POSTWORK 6

📂 POSTWORK 7

library(mongolite)
library(dplyr)

Importamos el csv

match.db <- read.csv("https://raw.githubusercontent.com/beduExpert/Programacion-R-Santander-2021/main/Sesion-07/Postwork/match.data.csv")

📋 Alojar match.data.csv a match_games

Conectamos el cluster con la base de datos “match_games” y la colección “match”

connection <- mongo(  collection = "match"
                    , db  = "match_games"
                    , url = "mongodb+srv://equipo10:bedu@postwork7.8voq3.mongodb.net/test")

Verificamos que si no hay documentos agregue los datos del csv

if (connection$count() == 0) {
  connection$insert(match.db)
}

📋 Número de Registros

Consultamos el número de registros

connection$count()
## [1] 3800

📋 Consulta Sintaxis Mongodb

Armamos el cuerpo de la consulta con sintaxis de mongodb

query = c('{ "$or": [ 
                    {"home_team": "Real Madrid"}
                  , {"away_team": "Real Madrid"}
                  ],
             "date": "2015-12-20"
        }')

Realizamos la consulta y ‘find’ convierte el resultado de la colección a dataframe

q.response <- connection$find(query)

Notamos que el Real Madrid solo jugó como local; contamos los goles y vemos quien fue el equipo contrincante

n.goles  <- 
    q.response %>% 
    filter(home_team == "Real Madrid") %>% 
    pull(home_score) %>% 
    sum()

vs.team  <-
    q.response %>% 
    filter(home_team == "Real Madrid") %>%
    pull(away_team)

Vemos los resultados

cat(paste( "Cantidad de goles metidos el 20-12-2015 por el Real Madrid: "
          , n.goles , "\n"
          , "Contra el equipo: "
          , vs.team
          , sep = ""))
## Cantidad de goles metidos el 20-12-2015 por el Real Madrid: 10
## Contra el equipo: Vallecano
if (n.goles > 4){cat(" ¡¡Fue una goleada!! ")}
##  ¡¡Fue una goleada!!

📂 POSTWORK 8

Debido a la identación y anidación que se genera al hacer el código se presenta por bloques comentado

📋 Creamos el logo para la aplicación Shiny

library(shiny)
library(shinydashboard)
library(dashboardthemes)
library(shinythemes)
library(plotly)

customLogo <- shinyDashboardLogoDIY(
    boldText = tags$a("Equipo 10",href="https://github.com/napoleonleal/R-BEDU-Project")
    , mainText = ""
    , textSize = 16
    , badgeText = "BEDU"
    , badgeTextColor = "white"
    , badgeTextSize = 3
    , badgeBackColor = "#000000"
    , badgeBorderRadius = 5
)

📋 Definimos la UI para la aplicacion

ui <- fluidPage(
    # Creamos la pagina con un dashboard
    dashboardPage( title = "Equipo 10",
                   # Definimos el header de la pagina
                   dashboardHeader(title = customLogo
                   ),
                   # Creamos una SideBar y definimos los elementos que contendra
                   dashboardSidebar(
                       sidebarMenu(
                           menuItem(  "Inicio"
                                    , tabName = "home"
                                    , icon = icon("home")),
                           menuItem(  "Graficas de barras"
                                    , tabName = "graficas"
                                    , icon = icon("bar-chart")),
                           menuItem(  "Goles casa - visitante"
                                    , tabName = "post3"
                                    , icon = icon("area-chart")),
                           menuItem(  "Data Table"
                                    , tabName = "data_table"
                                    , icon = icon("table")),
                           menuItem(  "Factores de Ganacias"
                                    , tabName = "ganacias"
                                    , icon = icon("money")),
                           menuItem(  "Repositorios"
                                    , tabName = "gh"
                                    , icon = icon("github"))
                       )
                   ),
                   # Definimos el body del dashboar
                   dashboardBody(
                       shinyDashboardThemes(
                          # Especificamos el tema que vamos a utlizar para la aplicacion
                           theme = "purple_gradient"
                       ),
                       # Definimos el cuerpo para cada tab del menu
                       tabItems(
                           # Inicio
                           tabItem(tabName = "home",
                                   fluidRow(
                                       column(8, align="center", offset = 2,
                                              strong( h1("BIENVENIDO AL SHINY DEL EQUIPO 10"),
                                                      h2("AQUI PODRÁS INTERACTUAR CON NUESTROS RESULTADOS"),
                                                      tags$br(),
                                                      h2("INTEGRANTES DEL EQUIPO: "),
                                                      h3("María Magdalena Castro Sam"), 
                                                      h3("Sergio Napoleón Leal"), 
                                                      h3("Jesús Omar Magaña Medina"),
                                                      h3("Fernando Itzama Novales Campos"), 
                                                      h3("Adrián Ramírez Cortés"), 
                                                      h3("Efraín Soto Olmos")
                                                    ),
                                              img(src = "blob.png", height = 250, width = 250),
                                              tags$style(type="text/css", "#string { height: 50px; width: 100%; text-align:center; font-size: 30px; display: block;}")
                                       )
                                   )
                           ),
                           # Grafica de barras de los goles
                           tabItem(tabName = "graficas",
                                   fluidRow(
                                     column(8, align="center", 
                                            offset = 2, 
                                            h1("Goles a favor y en contra por equipo")),
                                     selectInput("x", "Selecciona el valor de x",
                                                 choices = c("Goles Locales", 
                                                             "Goles Visitantes")),
                                     plotlyOutput("grafica8",height = 800)
                                   ),
                           ),
                           # Graficas Postwork 3
                           tabItem(tabName = "post3", 
                                   fluidRow(
                                       column(8, align="center", offset = 2,
                                              strong( h1("Gráficas del PostWork 3"))),
                                       box(title = "P(x) Marginal Equipo Local meta Gol",
                                           plotlyOutput("plotPW1")),
                                       box(title = "P(y) Marginal Equipo Visitante meta Gol",
                                           plotlyOutput("plotPW2")),
                                       box(title = "Figura 3.3 P(x∩y) conjunta",
                                           plotlyOutput("plotPW3"))
                                   )
                           ),
                           # Data table del archivo match.data.csv
                           tabItem(tabName = "data_table",
                                   fluidRow(        
                                     column(8, align="center", 
                                            offset = 2,  
                                            titlePanel(h3("Data Table de la Liga Española"))),
                                       dataTableOutput ("data_table")
                                   )
                           ), 
                           # Grafica de Momios
                           tabItem(tabName = "ganacias",
                                   fluidRow(
                                       column(8, align="center", offset = 2,
                                              strong( 
                                                h1("Gráficas de los factores de ganancia mínimo y máximo"))),
                                       column(9, align="right", offset = 2,
                                              radioButtons("picture", "Tipo de momios:",
                                                          c("Escenario con momios máximos",
                                                            "Escenario con momios promedio"))
                                              ),imageOutput("imagenMomios")
                                   )
                           ),
                           # Repositorios
                           tabItem(tabName = "gh",
                                   fluidRow(
                                      box(title= "Repositorio version GitHub", 
                                          tags$a(img(src= "git.png", 
                                                     height = 320, width = 580), 
                                                     href= "https://github.com/napoleonleal/R-BEDU-Project")),
                                      box(title="Repositorio version HTML",  
                                          tags$a(img(src= "page.png", height = 320, width = 580), 
                                                    href= "https://itzamango.github.io/postwork-equipo-10/"))
                                   )
                           )
                       )
                   )
    )
)

📋 Definimos las funciones del servidor

server <- function(input, output) {

    library(ggplot2)
    library(dplyr)
    library(viridis)
    library(viridisLite)
    
    # Leemos el archivo de los resultados de los partidos de la liga española desde 2010
    # hasta 2020
    df.resultado = read.csv("https://raw.githubusercontent.com/omar17md/ejemplo_1/main/df_resultado.csv")
    #Gráfico de goles
    output$grafica8 <- renderPlotly({
      if(input$x == "Goles Locales"){
        p =  ggplot(df.resultado, aes( x = home.score ) ) +
          geom_bar(aes(fill = Result)) +
          facet_wrap( ~ away.team ) +
          labs(y = "Goles")+
          scale_fill_discrete(name = "Resultados", 
                              labels = c("Gano Visitante", 
                                         "Empate", "Gano Local"))
        #  +scale_y_continuous(limits = c(0,50))
        
      }else{
        p =  ggplot(df.resultado, aes( x = away.score ) ) +
          geom_bar(aes(fill = Result)) +
          facet_wrap( ~ away.team ) +
          labs(y = "Goles")+
          scale_fill_discrete(name = "Resultados", 
                              labels = c("Gano Visitante", 
                                         "Empate", "Gano Local"))
        #  +scale_y_continuous(limits = c(0,50))
      }
      
      
      ggplotly(p)
        
    })
    # Función para obtener la frecuencia y probabilidad
    get.prob.df<- function(data, team, name.gol, name.prob){ 
        team      <- enquo(team)
        data %>% 
            pull(!!team) %>% 
            table(., dnn = (name.gol)) %>% 
            as.data.frame %>% 
            mutate(!!name.prob := Freq/sum(Freq)) 
    }
    
    # Función para redondear 3 digitos
    get.round <- function(data, digits){
        data %>% mutate_if(is.numeric, round, digits=digits)
    }
    
    # Función para obtener la probabilidad conjunta en objeto tabla
    get.prob.joint.tbl <- function(data, team.h, team.a, name.h, name.a){
      data %>%
        {table( team.h,  team.a, dnn = c(name.h, name.a)) } %>% 
        prop.table
    }
    # Gráficas del postwork3
    # Leemos el archivo que se genero en el postwork2
    data <- "https://raw.githubusercontent.com/napoleonleal/R-BEDU-Project/main/Postwork_2/Postwork_02.csv" %>%
        read.csv %>% 
        mutate(Date = as.Date(Date, "%Y-%m-%d"))
    
    #  calculamos la probabilidad marginal de los goles metidos por locales:
    prob.m.local <- 
        get.prob.df(data, FTHG, "Gol.Home", "P.Marginal") 
    
    prob.m.local %>% get.round(3)
    
    # Creamos una función para gráficar los datos
    plot.bar <- function(data, x.lab, y.lab, f.lab, title){
        Goles         <- data[1] %>% unlist()
        Porcentaje    <- (data[3]*100 ) %>% unlist %>% round(., digits=2)
        Prob.Marginal <- data[3] %>% unlist() %>% round(., digits=4)
        data %>%
            ggplot() +
            geom_bar(stat = 'identity') +
            aes(   x = Goles
                   , y = Porcentaje
                   , fill = Porcentaje
                   , text = paste("Prob Marginal", Prob.Marginal,
                                  group = interaction(Goles, Porcentaje))
            ) +
            labs(  x     = x.lab
                   , y     = y.lab
                   , fill  = f.lab
                   , title = title
            ) +
            theme_minimal() +
            theme( text = element_text(size=15)
                   ,legend.title = element_text(size=10) 
            ) +
            scale_fill_viridis(name=f.lab, direction = 1) 
    }
   #Primera grafica del postwork3
   output$plotPW1 <- renderPlotly({ 
       
       plot.local = plot.bar(prob.m.local
                              , "Goles [n]"
                              , "Probabilidad de ocurrencia [%]"
                              , "%"
                              , "Probabilidad de anotación del equipo local" )
       ggplotly(plot.local)
   })
   
   
   
    prob.m.visit <- 
      get.prob.df(data, FTAG, "Gol.Away", "P.Marginal") 
    
    
    prob.m.visit %>% get.round(3)
    
    #Segunda grafica del postwork 3
    output$plotPW2 <- renderPlotly({
      plot.visit <- plot.bar(prob.m.visit
                             , "Goles [n]"
                             , "Probabilidad de ocurrencia [%]"
                             , "%"
                             , "Probabilidad de anotación del equipo visitante" )
      
         ggplotly(plot.visit) 
    })
    # Calculamos la probabilidad conjunta de que el equipo que juega en casa anote *'x'*
    # goles y el equipo que juega como visitante anote '*y'* goles:
    prob.joint <- 
      get.prob.joint.tbl(data, data$FTHG, data$FTAG, "Local", "Visitante") 
    
    prob.joint  %<>% "*"(100) %>% round(2)
    
    prob.joint %<>% as.data.frame() %>% rename(Probabilidad = Freq)
    
    # Creamos la fucion para graficar el mapa de calor
    plot.heat <- function(data, x.lab, y.lab, f.lab, title){
      ggplot(data) +
        aes(   Local
               , Visitante
               , fill = Probabilidad
        ) + #gráficamos
        geom_raster() +
        labs(  x     = x.lab
               , y     = y.lab
               , fill  = f.lab
               , title = title
        ) +
        theme(  text = element_text(size=18)
                , legend.title = element_text(size=15) 
        ) +
        scale_fill_viridis(  name=f.lab
                             , direction = 1 #, option = "H"
        ) 
    }
    # Tercera grafica del postwork 3
    output$plotPW3 <- renderPlotly({
      plot.mapa.calor <-
        plot.heat(  prob.joint
                    , "Local [goles]"
                    , "Visitante [goles]"
                    , "Probabilidad [%]"
                    , "Probabilidad Conjunta de anotación"
        )
      
      ggplotly(plot.mapa.calor)    #versión interactiva 
    })
    #Data Table
    df = read.csv("https://raw.githubusercontent.com/napoleonleal/R-BEDU-Project/main/Postwork_8/match.data.csv")
    output$data_table <- renderDataTable( {df}, 
                                          options = list(aLengthMenu = c(5,25,50),
                                                         iDisplayLength = 50)
    )
    
    # Imagenes momios
    output$imagenMomios <- renderImage({   
        if(input$picture == "Escenario con momios máximos"){            
            list(src = "www/momios1.png", height = 520, width = 1200)
        }                                        
        else if(input$picture == "Escenario con momios promedio"){
            list(src = "www/momios2.png", height = 520, width = 1200)
        }
    }, deleteFile = FALSE)
}

# Corremos la aplicacion
shinyApp(ui = ui, server = server)

🏁 CONCLUSIONES FINALES